      Baraj ziua 3 (Selectie lot IOI, Cluj, mai 1996)
      Problema 7 (KWIC-index)

     Dndu-se o list[ de fraze i o list[ de cuvinte de ignorat, s[ se scrie un 
program care genereaz[, pornind de la o list[ de fraze, o list[ "indexat[" a 
acestora, numit[
               KWIC-index (Key Word In Context)
    Orice cuvnt care nu apare n lista de cuvinte de ignorat este un cuvnt 
cheie, deci un cuvnt dup[ care KWIC-indexul este ordonat.
    Astfel, dac[ lista de fraze este:
Concurs de baraj pentru lotul restrans.
Suntem la Cluj in luna mai.
Toti concurentii sunt bine pregatiti.
Concursul este greu.
    iar lista de cuvinte de ignorat este:
de,pentru,la,in,este,toti,sunt,suntem
KWIC-indexul generat va fi
                   Concurs de BARAJ pentru lotul restrans.
        Toti concurentii sunt BINE pregatiti.
                    Suntem la CLUJ in luna mai.
                         Toti CONCURENTII sunt bine pregatiti.
                              CONCURS de baraj pentru lotul restrans.
                              CONCURSUL este greu.
               Concursul este GREU.
      Concurs de baraj pentru LOTUL restrans.
            Suntem la Cluj in LUNA mai.
       Suntem la Cluj in luna MAI.
   Toti concurentii sunt bine PREGATITI.
Concurs de baraj pentru lotul RESTRANS.
    S[ se scrie un program care, pe baza unei liste de fraze, creaz[ KWIC-indexul 
corespunz[tor:
Date de intrare:
    In fiierul de tip text, al c[rui nume se citete de la tastatur[, se va da 
lista de fraze. Frazele conin cuvinte separate printr-un blanc. Nu exist[ semne 
de punctuaie, toate caracterele sunt litere mici i fraza se termin[ cu 
caracterul '.'.
Un cuvnt are mai puin de 20 caractere; exist[ cel mult 20.000 cuvinte.
    Intr-un alt fiier de tip text, al c[rui nume se citete de la tastatur[, 
se va da lista cuvintelor ignorate. Aceste cuvinte sunt scrise unul pe o linie.
Date de ieire:
    In fisierul de ieire, al c[rui nume se citete de la tastatur[, se va scrie 
KWIC-indexul generat.
Fiecare fraz[ se scrie pe o linie nou[.
Exemplu:
    Pentru coninutul fiierului de intrare cu lista frazelor:
concurs de baraj pentru lotul restrans.
suntem la cluj in luna mai.
toti concurentii sunt bine pregatiti.
concursul este greu.
    i coninutul fiierului de intrare al cuvintelor ignorate:
de
pentru
la
in
este
toti
sunt
suntem
    conintulul fiierului de iesire va fi:
concurs de baraj pentru lotul restrans.
toti concurentii sunt bine pregatiti.
suntem la cluj in luna mai.
toti concurentii sunt bine pregatiti.
concurs de baraj pentru lotul restrans.
concursul este greu.
concursul este greu.
concurs de baraj pentru lotul restrans.
suntem la cluj in luna mai.
suntem la cluj in luna mai.
toti concurentii sunt bine pregatiti.
concurs de baraj pentru lotul restrans.

Not[: Timp maxim de execuie: 30 secunde.
Punctaj maxim: 100 puncte.
================================================
Solutia 1 (Mihai Badoiu):
uses objects;

type
    parb=^arb;
    arb=record
             cuv:pstring;
             nr_curent:integer;
             left,right:parb;
             end;

var
    fo:text;
    nr_curent:integer;
    root:parb;
    n,m:integer;
    v:array[1..10000] of pstring;
    key:array[1..3000] of pstring;

procedure load;
var
    f:text;
    nume:string;
    j:integer;
begin
    write('fisier intrare (fraze) = ');
    readln(nume);
    assign(f,nume);
    reset(f);
    n:=0;
    while not eof(f) do
    begin
             readln(f,nume);
                                   while length(nume)>0 do
             begin
                           j:=pos('.',nume);
                           if j<>0 then
                           begin
                                              inc(n);
                                              v[n]:=NewStr(copy(nume,1,j));
                                              nume:=copy(nume,j+1,length(nume)-j);
                                              end;
                           end;
             end;
    close(f);
    write('fisier intrare (cuv. ign) = ');
    readln(nume);
    assign(f,nume);
    reset(f);
    m:=0;
    while not eof(f) do
    begin
             inc(m);
             readln(f,nume);
             key[m]:=NewStr(nume);
             end;
    close(f);
end;

procedure insert2(p:parb;var s:string);
begin
{$IFOPT F+}
             if s<>p^.cuv^ then
{$ENDIF}
             begin
                           if s<p^.cuv^ then
                           begin
                                              if p^.left<>nil then
                                                                      insert2(p^.left,s)
                                              else
                                              begin
                                                                      new(p^.left);
                                                                      p^.left^.left:=nil;
                                                                      p^.left^.right:=nil;
                                                                      p^.left^.cuv:=NewStr(s);
                                                                      p^.left^.nr_curent:=nr_curent;
                                                                      end
                                              end
                           else
                           begin
                                              if p^.right<>nil then
                                                                      insert2(p^.right,s)
                                              else
                                                                                          begin
                                                                      new(p^.right);
                                                                      p^.right^.left:=nil;
                                                                      p^.right^.right:=nil;
                                                                      p^.right^.cuv:=NewStr(s);
                                                                      p^.right^.nr_curent:=nr_curent;
                                                                      end
                                              end;
                           end;
end;

function gaseste(var s:string):boolean;
var
    i,j,k:integer;
begin
{   for i:=1 to m do
             if s=key[i]^ then
                           exit;}
    i:=1;
    j:=m;
    while i<=j do
    begin
             k:=(i+j) div 2;
             if s=key[k]^ then
             begin
                           gaseste:=true;
                           exit;
                           end
             else
             begin
                           if s<key[k]^ then
                                              j:=k-1
                           else
                                              i:=k+1;
                           end;
             end;
    gaseste:=false;
end;

procedure insert_arb(s:string);
begin
    if gaseste(s) then
             exit;
    if root=nil then
    begin
             new(root);
             root^.left:=nil;
             root^.right:=nil;
             root^.cuv:=NewStr(s);
             root^.nr_curent:=nr_curent;
                                   end
    else
             insert2(root,s);
end;

procedure scoate_cuv(s:string);
var
    i,j:integer;
begin
    while length(s)>0 do
    begin
             i:=pos(' ',s);
             j:=pos('.',s);
             if (j<>0) and (i>j) then
                           i:=j;
             if i=0 then
                           i:=j;
             if i<>0 then
             begin
                           insert_arb(copy(s,1,i-1));
                           s:=copy(s,i+1,length(s)-i);
                           end;
             end;
{   while length(s)>0 do
    begin
             i:=pos(' ',s);
             if i<>0 then
             begin
                           insert_arb(copy(s,1,i-1));
                           s:=copy(s,i+1,length(s)-i);
                           end;
             end;}
end;

procedure calcul;
begin
    for nr_curent:=1 to n do
    begin
             scoate_cuv(v[nr_curent]^);
             end;
end;

procedure scrie(p:parb);
begin
    if p=nil then
             exit;
    scrie(p^.left);
    writeln(fo,v[p^.nr_curent]^);
    scrie(p^.right);
end;
procedure sort;
var
    i,j:integer;
    p:pointer;
begin
    for i:=1 to m do
             for j:=i+1 to m do
                           if key[i]^>key[j]^ then
                           begin
                                              p:=key[i];
                                              key[i]:=key[j];
                                              key[j]:=p;
                                              end;
end;

var
    nume:string;
begin
    load;
    sort;
    calcul;
    write('fisier iesire = ');
    readln(nume);
    assign(fo,nume);
    rewrite(fo);
    scrie(root);
    close(fo);
end.
-----------------------------------
Solutia 2 (Catalin Francu):
program KwicSnax;
{$B-,I-,R-,S-}
const NMax=20000;
      PhMax=8000;
      IMax=3000;
type Cuv=String[20];
     Phrase=^Cell;
     Cell=record
            C:Cuv;
            Next,Prev:Phrase;
          end;
     PPP=record
           Head,Tail:Phrase;
         end;
     PhraseVector=array[1..PhMax] of PPP;
     IntList=^IntCell;
     IntCell=record
               I:Integer;
               Next:IntList;
             end;
     IgnoreVector=array[1..IMax] of Cuv;
     KWList=^KWCell;
     KWCell=record
              C:Cuv;
              Head,Tail:IntList;
              Next,Prev:KWList;
            end;
const VAX:Cuv='AAAAAAAA';

var Ig:IgnoreVector;
    NIg,N,NPh:Integer;
    KH,KT:KWList;
    P:^PhraseVector;
    SO:String;

procedure ReadCuv(var S:Cuv;var Sep:Char);
begin
  repeat Read(Sep) until not (Sep in ['.',' ',#9,#10,#13]);
  S:=Sep;
  while not (Sep in ['.',' ',#9,#10,#13,#26]) do
    begin
      Read(Sep);
      S:=S+Sep;
    end;
  Delete(S,Length(S),1);
end;

procedure PushWord(var S:Cuv);
begin
  with P^[NPh] do
    begin
      New(Tail^.Next);
      Tail^.Next^.Prev:=Tail;
      Tail:=Tail^.Next;
      Tail^.C:=S;
      Tail^.Next:=Nil;
    end;
end;

procedure ReadPhrase;
var Sep:Char;
    S:Cuv;
    PAux:Phrase;
begin
  Inc(NPh);
  with P^[NPh] do
    begin
      New(Head);
      Tail:=Head;
      Tail^.Next:=Nil;
      repeat
        ReadCuv(S,Sep);
        if Eoln then ReadLn;
        PushWord(S);
      until Sep='.';
      PAux:=Head^.Next;
      Dispose(Head);
      Head:=PAux;
      Head^.Prev:=Nil;
    end;
end;

procedure ReadData;
var SI,SF:String;
begin
  Write('Numele fisierului de intrare (fraze): ');ReadLn(SF);
  Write('Numele fisierului de intrare (cuvinte ignorate): ');ReadLn(SI);
  Write('Numele fisierului de iesire: ');ReadLn(SO);
  Assign(Input,SI);Reset(Input);
  NIg:=0;
  while not Eof do
    begin
      Inc(NIg);
      ReadLn(Ig[NIg]);
    end;
  Close(Input);

  Assign(Input,SF);Reset(Input);
  New(P);
  NPh:=0;
  while not Eof do
    ReadPhrase;
  Close(Input);
end;

procedure Fall(K,N:Integer);
var Son:Integer;
    CAux:Cuv;
begin
  if K+K>N
    then Son:=0
    else if (K+K+1<=N) and (Ig[K+K+1]>Ig[K+K])
             then Son:=K+K+1 else Son:=K+K;
  while (Son>0) and (Ig[Son]>Ig[K]) do
    begin
      CAux:=Ig[K];
      Ig[K]:=Ig[Son];
      Ig[Son]:=CAux;
      K:=Son;
      if K+K>N
        then Son:=0
        else if (K+K+1<=N) and (Ig[K+K+1]>Ig[K+K])
                 then Son:=K+K+1 else Son:=K+K;
    end;
end;

procedure SortIgnored;
var i:Integer;
    CAux:Cuv;
begin
  for i:=NIg div 2 downto 1 do Fall(i,NIg);
  for i:=NIg downto 2 do
    begin
      CAux:=Ig[1];
      Ig[1]:=Ig[i];
      Ig[i]:=CAux;
      Fall(1,i-1);
    end;
end;

procedure InitKW;
begin
  New(KH);
  KT:=KH;
  with KT^ do
    begin
      Prev:=Nil;
      Next:=Nil;
      C:=VAX;
      Head:=Nil;
      Tail:=Nil;
    end;
end;

procedure AddInt(var KW:KWList;K:Integer);
begin
  with KW^ do
    begin
      New(Tail^.Next);
      Tail:=Tail^.Next;
      Tail^.I:=K;
      Tail^.Next:=Nil;
    end;
end;

procedure MakeNew(var S:Cuv;var KW:KWList;K:Integer);
var KAux:KWList;
begin
  New(KAux);
  with KAux^ do
    begin
      New(Head);
      Tail:=Head;
      Tail^.Next:=Nil;
      Tail^.I:=K;
      Prev:=KW^.Prev;
      Next:=KW;
      if KW<>KH then KW^.Prev^.Next:=KAux
                else KH:=KAux;
      KW^.Prev:=KAux;
    end;
end;

procedure AddToTail(var S:Cuv;K:Integer);
begin
  New(KT^.Next);
  KT^.Next^.Prev:=KT;
  KT:=KT^.Next;
  with KT^ do
    begin
      Next:=Nil;
      C:=S;
      New(Head);
      Tail:=Head;
      Tail^.Next:=Nil;
      Tail^.I:=K;
    end;
end;

procedure Add(var S:Cuv;K:Integer);
var KAux:KWList;
begin
  KAux:=KH;
  while KAux<>Nil do
    begin
      if S>KAux^.C
        then KAux:=KAux^.Next
        else if S=KAux^.C then begin
                                 AddInt(KAux,K);
                                 Exit;
                               end
                          else begin
                                 MakeNew(S,KAux,K);
                                 Exit;
                               end;
    end;
  AddToTail(S,K);
end;

function Ignore(var S:Cuv;Lo,Hi:Integer):Boolean;
var K:Integer;
begin
  if Lo>Hi then Ignore:=False
  else if Lo=Hi
    then Ignore:=(S=Ig[Lo])
    else if Lo=Hi-1
           then Ignore:=(S=Ig[Lo]) or (S=Ig[Hi])
           else if (S=Ig[Lo]) or (S=Ig[Hi])
                  then Ignore:=True
                  else begin
                         K:=(Lo+Hi) div 2;
                         if S=Ig[K] then Ignore:=True
                           else if S>Ig[K]
                                  then Ignore:=Ignore(S,K+1,Hi-1)
                                  else Ignore:=Ignore(S,Lo+1,K-1);
                       end;
end;

procedure FindKW;
var i:Integer;
    PAux:Phrase;
begin
  for i:=1 to NPh do
    with P^[i] do
      begin
        PAux:=Head;
        while PAux<>Nil do
          begin
            if not Ignore(PAux^.C,1,NIg)
              then Add(PAux^.C,i);
            PAux:=PAux^.Next;
          end;
      end;
end;

procedure WritePhrase(K:Integer);
var PAux:Phrase;
begin
  PAux:=P^[K].Head;
  while PAux<>Nil do
    begin
      Write(PAux^.C);
      PAux:=PAux^.Next;
      if PAux<>Nil then Write(' ');
    end;
  WriteLn('.');
end;

procedure WriteSolution;
var IAux:IntList;
    KAux:KWList;
begin
  Assign(Output,SO);Rewrite(Output);
  KAux:=KH;
  while KAux<>Nil do
    begin
      IAux:=KAux^.Head;
      while IAux<>Nil do
        begin
          WritePhrase(IAux^.I);
          IAux:=IAux^.Next;
        end;
      KAux:=KAux^.Next;
    end;
  Close(Output);
end;

begin
  ReadData;
  SortIgnored;
  InitKW;
  FindKW;
  WriteSolution;
end.
------------------------------------------
solutia 3 (Ovidiu Ghiorghioiu):
{$A+,B-,D+z,E+,F-,G+,I+,L+,N-,O-,P-,Q-,R-,S-,T-,V+,X+,Y+}
{$M 65000,0,655360}
uses crt;
const cmax=3000;
type str=record
               l:integer;
               s:array[1..20000] of char
     end;
     pstr=^str;
     pstring=^string;
procedure newstr(var p:pstr;var s:str);
begin
     getmem(p,s.l+2);
     move(s,p^,s.l+2)
end;
procedure newstring(var p:pstring;var s:string);
begin
     getmem(p,length(s)+1);
     move(s,p^,length(s)+1)
end;
var t:array[1..cmax] of pstr;
    c,ig:array[1..cmax] of pstring;
    ct:array[1..cmax] of integer;
    nt,nc,nig,i,j,k,l:integer;
    s:string;
    x:string[20];
    y:pstring;
    yy:pstr;
    inw:boolean;
    st:str;
    ch:char;
    f:text;
procedure citeste;
begin
     write('Numele fis. de fraze: ');readln(s);
     assign(f,s);
     reset(f);
     nt:=0;
     st.l:=0;
     while not eof(f) do begin
           read(f,ch);
           inc(st.l);
           st.s[st.l]:=ch;
           if ch='.' then begin
              inc(nt);
              newstr(t[nt],st);
              st.l:=0;
           end;
           if eoln(f) then readln(f);
     end;
     close(f);
     write('Numele fis. de cuvinte ignorate: ');readln(s);
     assign(f,s);
     reset(f);
     nig:=0;
     while not seekeof(f) do begin
           readln(f,s);
           inc(nig);
           newstring(ig[nig],s)
     end;
     close(f);
     write('Numele fis. de iesire: ');readln(s);
     assign(f,s);
     rewrite(f);
end;
procedure cuvinte;
label 1;
begin
     nc:=0;
     s[0]:=#0;
     inw:=false;
     for i:=1 to nt do
         for j:=1 to t[i]^.l do begin
             ch:=t[i]^.s[j];
             if (ch=' ') or (ch='.') then
             if inw then begin
                s[0]:=chr(j-k);
                move(t[i]^.s[k],s[1],j-k);
                inw:=false;
                for l:=1 to nig do if s=ig[l]^ then goto 1;
                inc(nc);
                newstring(c[nc],s);
                ct[nc]:=i;
             1:end else
             else if not inw then begin
                  inw:=true;
                  k:=j
             end
         end;
end;
procedure sort(l,r: Integer);
var
  i: integer;
begin
  i:=l; j:=r; x:=c[(l+r) div 2]^;
  repeat
    while c[i]^<x do inc(i);
    while x<c[j]^ do dec(j);
    if i <= j then
    begin
      y:=c[i];c[i]:=c[j];c[j]:=y;
      l:=ct[i];ct[i]:=ct[j];ct[j]:=l;
      inc(i); dec(j);
    end;
  until i>j;
  if l<j then sort(l,j);
  if i<r then sort(i,r);
end;

procedure rezolva;
begin
     cuvinte;
     sort(1,nc);
     for i:=1 to nc do begin
         yy:=t[ct[i]];
         for j:=1 to yy^.l do write(f,yy^.s[j]);
         writeln(f)
     end;
     close(f);
end;
begin
     citeste;
     rezolva;
end.
----------------------------
solutia 4 (Vlad Petric):
{$A+,B-,D+,E+,F-,G-,I+,L+,N-,O-,P-,Q-,R-,S+,T-,V-,X-,Y+}
{$M 16384,0,0}
program kwicindex;
uses dos,strings;
type cuv=string[20];
var except:array[1..3000] of cuv;
    ne:integer;

function exceptie(var x:cuv):boolean;
var i:byte;
begin
  for i:=1 to ne do
    if x=except[i] then begin
      exceptie:=true;
      exit;
    end;
  exceptie:=false;
end;

procedure citire;
var f,fo,fop:text;
    nf:string;
    ch:char;
    cuvant:cuv;
    fraza:string;
begin
  write('Nume fisier cuvinte exceptate:');
  readln(nf);
  assign(f,nf);
  reset(f);
  ne:=0;
  while not seekeof(f) do begin
    inc(ne);
    readln(f,except[ne]);
  end;
  close(f);
  assign(fo,'$$.tmp');
  assign(fop,'xxx.tmp');
  rewrite(fop);
  rewrite(fo);
  write('Nume fisier intrare:');
  readln(nf);
  assign(f,nf);
  reset(f);
  while not eof(f) do begin
    cuvant:='';
    fraza:='';
    while not eoln(f) do begin
      read(f,ch);
      if ch=' ' then begin
        if (cuvant <>'') and not exceptie(cuvant)  then writeln(fo,cuvant);
        if fraza<>'' then fraza:=fraza+' '+cuvant
                     else fraza:=cuvant;
        cuvant:='';
      end
      else
        if ch='.' then begin
          if (cuvant<>'') and not exceptie(cuvant)  then writeln(fo,cuvant);
          if fraza<>'' then fraza:=fraza+' '+cuvant
                     else fraza:=cuvant;

          cuvant:='';
          writeln(fop,fraza);
          fraza:='';
        end
        else
          cuvant:=cuvant+ch;
    end;
    readln(f);
  end;
  close(f);
  close(fo);
  close(fop);
  Exec(GetEnv('COMSPEC'),'/c sort <$$.tmp > x.tmp');
end;

procedure tratare;
var f1,f2,fo:text;
    nf,s:string;
    aux:boolean;
    cuvant,clast:cuv;
begin
  writeln('Nume fisier iesire:');
  readln(nf);
  assign(fo,nf);
  rewrite(fo);
  assign(f1,'x.tmp');
  reset(f1);
  clast:='';
  while not seekeof(f1) do begin
    readln(f1,cuvant);
    assign(f2,'xxx.tmp');
    reset(f2);
    aux:=true;
    if cuvant=clast then
      aux:=false;
    while aux and (not seekeof(f2)) do begin
      readln(f2,s);
      s:=s+'.';
      if (cuvant<>'') and (cuvant<>' ') and (Pos(cuvant,s)<>0) and (s[Pos(cuvant,s)+length(cuvant)] in ['
','.']) then begin
        writeln(fo,s);
{        aux:=false;}
      end;

    clast:=cuvant;
    end;
    close(f2);
  end;
  close(f1);
  close(fo);
end;




begin
  writeln;
  writeln;
  citire;
  tratare;
end.
----------------------------
